home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Menus / ftpMenu.tcl < prev    next >
Encoding:
Text File  |  1997-12-10  |  10.6 KB  |  425 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*- (install)
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "ftpMenu.tcl"
  6.  #                                    created: 20/7/96 {6:02:55 pm} 
  7.  #                                last update: 8/10/97 {6:19:26 pm} 
  8.  #  
  9.  #  Description: 
  10.  # 
  11.  # ###################################################################
  12.  ##
  13.  
  14. alpha::menu ftpMenu    0.1 "•141" in_menu {} uninstall {this-file} \
  15.   help {[editMark "$HOME:Help:Alpha Manual" "Ftp Browser" -r]}
  16.  
  17. hook::register savePostHook ftpPostHook
  18.  
  19. proc ftpMenu {} {}
  20.  
  21. proc ftpPostHook {name} {
  22.     global fetched
  23.     if {[info exists fetched($name)]} {
  24.         set specs $fetched($name)
  25.         message "Updating '[file tail $name]' on [car $specs]…"
  26.         if {[string length [cadr $specs]]} {
  27.             ftpStore $name [car $specs] "[cadr $specs]/[file tail $name]" [caddr $specs] [cadddr $specs]
  28.         } else {
  29.             ftpStore $name [car $specs] "[file tail $name]" [caddr $specs] [cadddr $specs]
  30.         }
  31.     }
  32. }
  33.  
  34. proc rebuildFtpMenu {} {
  35.     global savedMounts recentMounts ftpMenu useCache
  36.     
  37.     menu -n $ftpMenu -p ftpMenuProc {
  38.         help
  39.         "(-"
  40.         "<S/ibrowse…"
  41.         "<S/i<IbrowseCurrent…"
  42.         "/nbrowseMounts…"
  43.         "(-"
  44.         addMountPoint…
  45.         makePermanent…
  46.         removeMountPoint…
  47.         saveAsAt…
  48.         "(-"
  49.         useCache
  50.         flushCache
  51.         "(-"
  52.         "createFileset"
  53.         "(-"
  54.     }
  55.     markMenuItem -m $ftpMenu "Use Cache" $useCache
  56.     if {[info exists savedMounts]} {
  57.         foreach m [lsort -ignore [array names savedMounts]] {
  58.             addMenuItem -m -l "b " $ftpMenu $m
  59.         }
  60.     }
  61.     if {[info exists recentMounts]} {
  62.         addMenuItem -m $ftpMenu "(-"
  63.         foreach m [lsort -ignore [array names recentMounts]] {
  64.             addMenuItem -m -l "b " $ftpMenu $m
  65.         }
  66.     }
  67. }
  68.  
  69. if {![info exists useCache]} {set useCache 1}
  70.  
  71. app::registerMultiple ftp [list Arch FTCh] [list •141 •315] rebuildFtpMenu
  72.  
  73. proc mountPoints {} {
  74.     global savedMounts recentMounts
  75.     if {[info exists recentMounts]} {
  76.         if {[info exists savedMounts]} {
  77.             set l [concat [array names recentMounts] [array names savedMounts]]
  78.         } else {
  79.             set l [array names recentMounts]]
  80.         }
  81.     } else {
  82.         set l [array names savedMounts]
  83.     }
  84.     return [lsort $l]
  85. }
  86.  
  87.  
  88.  
  89. proc ftpMenuProc {menu item} {
  90.     global modifiedVars modifiedArrVars savedMounts recentMounts PREFS fetched HOME ftpMenu useCache createFtpType
  91.     switch $item {
  92.         help                {editMark "$HOME:Help:Alpha Manual" "Ftp Browser" -r}
  93.         browse                {eval ftpBrowse [lrange [getLogin {Browse remote machine:} 0] 0 3]}
  94.         browseCurrent        { if {[info exists fetched([win::Current])]} {
  95.                                 eval ftpBrowse $fetched([win::Current]) 
  96.                             } else {
  97.                                 beep; message "'[win::CurrentTail]' not from remote host."
  98.                             }}
  99.         browseMounts        {
  100.             set l [mountPoints]
  101.             set res [listpick -p "Mount point:" $l]
  102.             if {[info exists recentMounts($res)]} {
  103.                 eval ftpBrowse $recentMounts($res)
  104.             } else {
  105.                 eval ftpBrowse $savedMounts($res)
  106.             }
  107.         }
  108.  
  109.         addMountPoint        { addMountPoint }
  110.         makePermanent        { makeMountPermanent }
  111.         createFileset        { ftpCreateFileset }
  112.         removeMountPoint    {
  113.             set pt [listpick -p "Remove which mount point?" [lsort -ignore [array names savedMounts]]]
  114.             unset savedMounts($pt)
  115.             removeArrDef savedMounts $pt
  116.             rebuildFtpMenu
  117.         }
  118.         saveAsAt            {
  119.             global fetched PREFS
  120.             set name [prompt "Name:" [win::CurrentTail]]
  121.             set point [listpick -p "At which mount point?" [mountPoints]]
  122.             if {[info exists recentMounts($point)]} {
  123.                 set specs $recentMounts($point)
  124.             } else {
  125.                 set specs $savedMounts($point)
  126.             }
  127.             set name "$PREFS:ftptmp:$name"
  128.             set fetched($name) $specs
  129.             message "Saving '$name' on [car $specs]…"
  130.             
  131.             if {![file exists $name]} {
  132.                 set fid [open $name w]
  133.                 close $fid
  134.             }
  135.             saveAs -f "$name"
  136.             
  137.             set num 0
  138.             set pathname [cadr $specs]
  139.             for {set i [expr [string length $pathname] - 1]} {$i >= 0} {incr i -1} {
  140.                 scan $pathname "%c" char
  141.                 incr num $char
  142.             }
  143.             
  144.             set nm "$PREFS:ftptmp:listing.$num"
  145.             catch {rm $nm}
  146.             
  147.             setWinInfo platform $createFtpType
  148.             setWinInfo dirty 1
  149.             save
  150.         }
  151.         
  152.         setDefaults            { 
  153.             global ftpDefaults modifiedVars
  154.             set ftpDefaults [lrange [getLogin "Enter defaults that you wish saved:" 0] 0 3]
  155.             lappend modifiedVars ftpDefaults
  156.         }
  157.         flushCache        { rm "$PREFS:ftptmp:*"; [catch {unset recentMounts}]; rebuildFtpMenu }
  158.         useCache    { 
  159.             set useCache [expr 1 - $useCache]
  160.             markMenuItem -m $ftpMenu "Use Cache" $useCache
  161.             lappend modifiedVars useCache
  162.         }
  163.         default {
  164.             if {[info exists recentMounts($item)]} {
  165.                 eval ftpBrowse $recentMounts($item)
  166.             } else {
  167.                 eval ftpBrowse $savedMounts($item)
  168.             }
  169.         }
  170.     }
  171. }
  172.  
  173.  
  174. proc ftpFilesetOpen {menu item} {
  175.     global gfileSets PREFS fetched fileSetsExtra
  176.     
  177.     if {[set ind [lsearch $gfileSets($menu) "*$item"]] >= 0} {
  178.         set f [lindex $gfileSets($menu) $ind]
  179.         set lnm [file tail $f]
  180.         regsub -all {:} $f {/} f
  181.         set nm "$PREFS:ftptmp:$lnm"
  182.         set specs $fileSetsExtra($menu)
  183.         if {![file exists $nm]} {
  184.             ftpFetch $nm [car $specs] $f [caddr $specs] [cadddr $specs]
  185.         }
  186.         edit -w $nm
  187.         set fetched($nm) $specs
  188.     }
  189. }
  190.  
  191.  
  192. proc ftpCreateFileset {} {
  193.     global gfileSets gfileSetsType PREFS fileSetsExtra
  194.     
  195.     set specs [getLogin]
  196.     set name [car $specs]
  197.     set host [cadr $specs]
  198.     set path [caddr $specs]
  199.     set user [cadddr $specs]
  200.     set password [caddddr $specs]
  201.     set pattern "^[prompt {Name pattern?} {.*.[ch]}]$"
  202.     set path [string trimright $path {/}]
  203.  
  204.     set fileSetsExtra($name) [list $host $path $user $password]
  205.     
  206.     if { ![file exists "$PREFS:ftptmp:"] } {
  207.         mkdir "$PREFS:ftptmp:"
  208.     }
  209.     set nm "$PREFS:ftptmp:listing.$path"
  210.     ftpList $nm $host $path $user $password
  211.     set files {}
  212.     foreach f [processListing $nm] {
  213.         if {![string match {*/} $f] && [regexp $pattern $f]} {
  214.             lappend files "$path/$f"
  215.         }
  216.     }
  217.     regsub -all {/} $files {:} files
  218.  
  219.     global gfileSets gfileSetsType
  220.     set gfileSets($name) [lsort -command sortByTail $files]
  221.     set gfileSetsType($name) ftp
  222.     if {[askyesno "Save project fileset?"] == "yes"} {
  223.         addArrDef gfileSetsType $name ftp
  224.         addArrDef gfileSets $name  $gfileSets($name)
  225.         addArrDef fileSetsExtra $name $fileSetsExtra($name)
  226.     }
  227.     return $name
  228. }
  229.  
  230.  
  231. proc processListing {path} {
  232.     set fd [open $path "r"]
  233.     set lines [split [read $fd] "\n"]
  234.     close $fd
  235.     set files {}
  236.     foreach f [cdr [lreplace $lines end end]] {
  237.         set nm [lindex $f end]
  238.         if {[string length $nm]} {
  239.             if {[string match "d*" $f]} {
  240.                 lappend files "$nm/"
  241.             } else {
  242.                 lappend files $nm
  243.             }
  244.         }
  245.     }
  246.     return $files
  247. }
  248.  
  249. proc getLogin {{prompt {All but 'password' are required:}} {nm 1}} {
  250.     global ftpDefaults
  251.     if {[info exists ftpDefaults]} {
  252.         set defs $ftpDefaults
  253.     } else {
  254.         set defs {"" "" "" ""}
  255.     }
  256.     set left 10
  257.     set right 100
  258.     set top 10
  259.     set bottom 30
  260.     set eleft [expr $left + 100]
  261.     set eright 370
  262.     set incr 30
  263.  
  264.     set height 198
  265.     
  266.     if $nm {incr height $incr}
  267.     set l "dialog -w 400 -h $height -t [list $prompt] $left $top 400 $bottom"
  268.     
  269.     if {$nm} {
  270.         incr top $incr
  271.         incr bottom $incr
  272.         lappend l -t {Name:} $left $top $right $bottom
  273.         lappend l -e {} $eleft $top $eright $bottom
  274.     }
  275.     
  276.     incr top $incr
  277.     incr bottom $incr
  278.     lappend l -t {Host:} $left $top $right $bottom
  279.     lappend l -e [car $defs] $eleft $top $eright $bottom
  280.     
  281.     incr top $incr
  282.     incr bottom $incr
  283.     lappend l -t {Path:} $left $top $right $bottom
  284.     lappend l -e [cadr $defs] $eleft $top $eright $bottom
  285.     
  286.     incr top $incr
  287.     incr bottom $incr
  288.     lappend l -t {UserID:} $left $top $right $bottom
  289.     lappend l -e [caddr $defs] $eleft $top $eright $bottom
  290.     
  291.     incr top $incr
  292.     incr bottom $incr
  293.     lappend l -t {Password:} $left $top $right $bottom
  294.     lappend l -e [cadddr $defs] $eleft [expr $top + 6] $eright [expr $bottom - 12]
  295.     
  296.     incr top [expr $incr + 10]
  297.     incr bottom [expr $incr + 10]
  298.     lappend l -b "OK" $left $top $right [expr $top + 20]
  299.     lappend l -b "Cancel" [expr $left + 200] $top [expr $right + 200] [expr $top + 20]
  300.     
  301.     set res [eval "$l"]
  302.     if {[lindex $res end]} {error "Cancel"}
  303.     return $res
  304. }
  305.  
  306.  
  307. proc addMountPoint {} {
  308.     global savedMounts modifiedArrVars
  309.     
  310.     set res [getLogin]
  311.     if {[lindex $res 5]} {
  312.         set savedMounts([car $res]) [lrange $res 1 4]
  313.         lappend modifiedArrVars savedMounts
  314.         rebuildFtpMenu
  315.     }
  316. }
  317.  
  318.  
  319. proc makeMountPermanent {} {
  320.     global recentMounts savedMounts modifiedArrVars
  321.     if {![info exists recentMounts]} {
  322.         alertnote "You have no temporary mounts."
  323.         return
  324.     }
  325.     set res [listpick -p "Make which temporary mount point permanent?" [lsort [array names recentMounts]]]
  326.     set name [prompt "Name?" $res]
  327.     set savedMounts($name) $recentMounts($res)
  328.     unset recentMounts($res)
  329.     lappend modifiedArrVars savedMounts
  330.     rebuildFtpMenu
  331. }
  332.  
  333.  
  334. proc ftpPromptBrowse {} {
  335.     eval ftpBrowse [lrange [getLogin {Browse remote machine:} 0] 0 3]
  336. }
  337.  
  338. proc ftpBrowse {host dir user password {fname {}}} {
  339.     global PREFS fetched lastFtpDir recentMounts savedMounts useCache
  340.  
  341.     watchCursor
  342.     if {![string length $password]} {
  343.         set password [getPassword $host]
  344.     }
  345.  
  346.     if {![file exists "$PREFS:ftptmp"]} {
  347.         mkdir "$PREFS:ftptmp"
  348.     }
  349.     if {$dir == {-}} {
  350.         if {![info exists lastFtpDir] || ![string length $lastFtpDir]} {set lastFtpDir ""}
  351.         set dir [prompt "'$host' dir:" $lastFtpDir]
  352.     }
  353.     set dir [string trimright $dir {/}]
  354.     set lastFtpDir $dir
  355.  
  356.     set num 0
  357.     for {set i [expr [string length $dir] - 1]} {$i >= 0} {incr i -1} {
  358.         scan $dir "%c" char
  359.         incr num $char
  360.     }
  361.     
  362.     set nm "$PREFS:ftptmp:listing.$num"
  363.     
  364.     if {!$useCache || ![file exists $nm]} {
  365.         ftpList $nm $host $dir $user $password
  366.     }
  367.     if {[catch {processListing $nm} listing]} {
  368.         alertnote "Error fetching directory '$dir'"
  369.         error "Error fetching directory '$dir'"
  370.     }
  371.     set files [concat {..} $listing]
  372.     if {$fname != ""} {
  373.         set file [listpick -L $fname -p "$dir/" $files]
  374.     } else {
  375.         set file [listpick -p "$dir/" $files]
  376.     }
  377.     
  378.     if {$file == {..}} {
  379.         if {[regexp {((/|\w)+)/\w+} $dir dummy sub]} {
  380.             return [ftpBrowse $host $sub $user $password]
  381.         } else {
  382.             return [ftpBrowse $host "" $user $password]
  383.         }
  384.     }
  385.  
  386.     if {[string match {*/} $file]} {
  387.         if {[string length $dir]} {
  388.             return [ftpBrowse $host [string trimright "$dir/$file" {/}] $user $password]
  389.         } else {
  390.             return [ftpBrowse $host [string trimright "$file" {/}] $user $password]
  391.         }
  392.     }
  393.  
  394.     set entry [list $host $dir $user $password]
  395.     set new 1
  396.     foreach name [array names savedMounts] {
  397.         if {([car $savedMounts($name)] == [car $entry]) && ([cadr $savedMounts($name)] == [cadr $entry])} {
  398.             set new 0
  399.             break;
  400.         }
  401.     }
  402.     if $new {
  403.         set recentMounts($dir) $entry
  404.         rebuildFtpMenu
  405.     }
  406.     
  407.     set nm "$PREFS:ftptmp:$file"
  408.     if {!$useCache || ![file exists $nm]} {
  409.         if {[string length $dir]} {
  410.             ftpFetch $nm $host "$dir/$file" $user $password
  411.         } else {
  412.             ftpFetch $nm $host "$file" $user $password
  413.         }
  414.     }
  415.     edit -w $nm
  416.     set fetched($nm) [list $host $dir $user $password]
  417. }
  418.  
  419. proc getPassword {host} {
  420.     set values [dialog -w 300 -h 90 -t "Password for $host:" 10 20 290 30 \
  421.         -e "" 10 40 290 42 -b OK 20 60 85 80 -b Cancel 105 60 170 80]
  422.     if {[lindex $values 2]} {error "Cancel"}
  423.     return [string trim [lindex $values 0]]
  424. }
  425.